home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / PRUS101.ZIP / FSTR.PAS < prev    next >
Pascal/Delphi Source File  |  1994-12-19  |  18KB  |  600 lines
  1. UNIT FSTR; { FIDO unit for string handling and manipulation }
  2.  (***************************************************************************
  3.  
  4.             RELEASE 1.06 - as contained in the file PRUS101.LZH
  5.                 by Peter Holschbach, 2:2450/660.3,  GERMANY
  6.  
  7.                --------------------------------------------
  8.                 organized for Fido's PASCAL related echoes
  9.                --------------------------------------------
  10.  
  11.      05/14/1994 to 06/26/1994 by Orazio Czerwenka, 2:2450/540.55, GERMANY
  12.      06/26/1994 to --/--/---- by Peter Holschbach, 2:2450/660.3,  GERMANY
  13.  
  14.  
  15.            As far as third party copyrights are not violated this
  16.            source code is hereby placed to the public domain. Use
  17.            it whatever way you want, but use AT YOUR OWN RISK.
  18.  
  19.            In case you should modify the source rather send your
  20.            modifications to the unit's current organizer (see above for
  21.            NM address) than to spread it on your own. This will help to
  22.            keep the unit updated and grant a certain standard to all
  23.            other users as well.
  24.  
  25.            The unit is currently still under work. So it might greatly
  26.            benefit of your participation.
  27.  
  28.            Those who contributed to the following piece of source,
  29.            listed in alphabethical order:
  30.         ================================================================
  31.            Orazio Czerwenka, Peter Holschbach, Peter Schuette ...
  32.         ================================================================
  33.            YOUR NAME WILL APPEAR HERE IF YOU CONTRIBUTE USEFUL SOURCE.
  34.  
  35.            Credits in your own programs are as welcome as unnecessary.
  36.  
  37.  ***************************************************************************)
  38.  
  39. {$I FDEFINE.DEF}
  40.  
  41. interface
  42.  
  43. type
  44.   FieldOfStrings = Array [0..20]  of String;
  45.  
  46. Var PartCount    : Word;
  47.  
  48.   function PosCount (findstr, strName : String): Byte;
  49.   function RedPosCount (findstr, strName: String): Byte;
  50.   function PosX (Xpos: byte; findstr, strName: String): Byte;
  51.   function LastPos (findstr, strName: String): Byte;
  52.   function CharListPos (findlst,strName: String) : Word;
  53.   function CharListNoPos (findlst,strName: String): Word;
  54.  
  55.   function MirrorString (strName: String): String;
  56.   function UpperString (strName: String): String;
  57.   function LowerString (strName: String): String;
  58.  
  59.   function RemoveLeft (remo,strName: String): String;
  60.   function RemoveRight (remo,strName: String): String;
  61.   function RemoveLeftRight (remo,strName: String): String;
  62.   function RemoveAll (remo,strName: String): String;
  63.  
  64.   function StripSpaceTAB (strName: String): String;
  65.   function StripLeadingSpaceTAB (strName: String): String;
  66.  
  67.   procedure PartString (PartBy: String; Var StringField : FieldOfStrings);
  68.  
  69.   procedure PartStringBySpaceTAB (Var StringField : FieldOfStrings);
  70.   procedure PartStringByComma (Var StringField : FieldOfStrings);
  71.  
  72.   function Resemble (a, b: String): Byte;
  73.  
  74.   function WildMatch (Pattern,Source: String) : Boolean;
  75.   function EnsureBackslash (strName: String) : String;
  76.   function EnsureNoBackslash (strName: String) : String;
  77.  
  78.   Function  EscToString (strName:String) : String;
  79.   Function  StringToEsc (strName:String) : String;
  80.  
  81. implementation
  82.  
  83. Type
  84.   CharArray255   = Array [1..255] of Char;
  85.  
  86. {----------------------------------------------------------------------------}
  87.  
  88. function CharListPos(findlst,strName: String) : Word;
  89. { Original author: Peter Holschbach,
  90.   modifications Orazio Czerwenka }
  91. Var L            : Word;
  92.     Position     : Word;
  93.     TempPosition : Word;
  94. Begin
  95.   If strName = '' then Begin
  96.     CharListPos:= 0;
  97.     Exit;
  98.   End;
  99.   Position := 256;
  100.   For L := 1 to Length (findlst) do Begin
  101.     TempPosition := Pos (findlst [L],strName);
  102.     If (TempPosition > 0) and (TempPosition < Position)
  103.       then Position := TempPosition;
  104.   End;
  105.   If Position = 256 then CharListPos:= 0
  106.   Else CharListPos:= Position;
  107. End;
  108.  
  109. {----------------------------------------------------------------------------}
  110.  
  111. function CharListNoPos (findlst,strName: String): Word;
  112. { Original author: Peter Holschbach,
  113.   modifications Orazio Czerwenka }
  114. Var L            : Word;
  115.     Position     : Word;
  116.     InFindLst    : Boolean;
  117. Begin
  118.   If strName = '' then Begin
  119.     CharListNoPos:= 0;
  120.     Exit;
  121.   End;
  122.   Position := 1;
  123.   Repeat
  124.     InFindLst := False;
  125.     For L:= 1 to Length (findlst) do
  126.       If (strName [Position] = findlst [L]) then InFindLst := True;
  127.     Inc (Position);
  128.   Until (Position > Length (strName)) OR Not InFindLst;
  129.   If Not InFindLst
  130.     then CharListNoPos:= Position - 1
  131.     else CharListNoPos:= Length(strName)+1;
  132. End;
  133.  
  134. {----------------------------------------------------------------------------}
  135.  
  136. function PosCount (findstr,strName:String):byte;
  137. { Original author: Orazio Czerwenka }
  138. VAR
  139.   i,
  140.   b     :       byte;
  141.   tmpstr:       string;
  142. BEGIN
  143.   b:= 0;
  144.   tmpstr:= strName;
  145.     FOR i:= 1 TO Length(tmpstr) DO
  146.       IF copy(tmpstr,i,length(findstr))= findstr THEN BEGIN
  147.         inc(b);
  148.         delete(tmpstr,i,length(findstr)-1);
  149.       END;
  150.   IF b > 0
  151.     THEN PosCount:= b
  152.     ELSE PosCount:= 0;
  153. END;
  154.  
  155. {----------------------------------------------------------------------------}
  156.  
  157. function RedPosCount (findstr,strName:String):byte;
  158. { Original author: Orazio Czerwenka }
  159. VAR
  160.   i,
  161.   b     :       byte;
  162. BEGIN
  163.   b:= 0;
  164.   FOR i:= 1 TO Length(strName)-(length(findstr)-1) DO
  165.     IF copy(strname,i,length(findstr))= findstr THEN inc(b);
  166.   IF b > 0
  167.     THEN RedPosCount:= b
  168.     ELSE RedPosCount:= 0;
  169. END;
  170.  
  171. {----------------------------------------------------------------------------}
  172.  
  173. function LastPos (findstr,strName:String):Byte;
  174. { Original author: Orazio Czerwenka }
  175. VAR
  176.   b     :       Byte;
  177. BEGIN
  178.   b:= Pos(MirrorString(findstr),MirrorString(strName));
  179.   IF b > 0
  180.     THEN LastPos:= (length(strName)+1)-b-(length(findstr)-1)
  181.     ELSE LastPos:= b;
  182. END;
  183.  
  184. {----------------------------------------------------------------------------}
  185.  
  186. function PosX (Xpos: byte; findstr, strName: String): Byte;
  187. { Original author: Orazio Czerwenka }
  188. Var
  189.   X,
  190.   b     :       Byte;
  191. begin
  192.   X:= 0;
  193.   for b:= 1 to Xpos do begin
  194.     X:= X + pos(findstr,strName);
  195.     delete (strName,1,pos(findstr,strName)+ord(findstr[0])-1);
  196.   end;
  197.   PosX:= X;
  198. end;
  199.  
  200. {----------------------------------------------------------------------------}
  201.  
  202. function MirrorString (strName:string):string;
  203. { Original author: Orazio Czerwenka }
  204. VAR
  205.   n            :       byte;
  206.   NewStr       :       string;
  207. BEGIN
  208.   MirrorString:= strName;
  209.   NewStr:= '';                           { Necessary to initialize variable }
  210.   if strName = '' then exit;
  211.   FOR n:= 0 TO length(strName)-1 DO
  212.     NewStr:= NewStr + strName[length(strName)-n];
  213.   MirrorString:= NewStr;
  214. END;
  215.  
  216. {----------------------------------------------------------------------------}
  217.  
  218. function UpperString(strName:String):String;
  219. { Original author: Orazio Czerwenka }
  220. VAR
  221.   n     :       byte;
  222. BEGIN
  223.   FOR n:=1 TO Length(strName) DO
  224.     CASE ord(strName[n]) OF
  225.       129 : strName[n]:= chr(154);                { ue - Ue }
  226.       130 : strName[n]:= chr(144);                { é - É }
  227.       132 : strName[n]:= chr(142);                { ae - Ae }
  228.       134 : strName[n]:= chr(143);                { å - Å }
  229.       135 : strName[n]:= chr(128);                { ç - Ç }
  230.       145 : strName[n]:= chr(146);                { æ - Æ }
  231.       148 : strName[n]:= chr(153);                { oe - Oe }
  232.       164 : strName[n]:= chr(165);                { ñ - Ñ }
  233.     ELSE strName[n]:= UpCase(strName[n]);
  234.     END;
  235.   UpperString:=StrName;
  236. END;
  237.  
  238. {----------------------------------------------------------------------------}
  239.  
  240. function LowerString(strName:String):String;
  241. { Original author: Orazio Czerwenka }
  242. VAR
  243.   n     :       byte;
  244. BEGIN
  245.   FOR n:=1 TO Length(strName) DO
  246.     CASE ord(strName[n]) OF
  247.       154 : strName[n]:= chr(129);                { Ue - ue }
  248.       144 : strName[n]:= chr(130);                { É - é }
  249.       142 : strName[n]:= chr(132);                { Ae - ae }
  250.       143 : strName[n]:= chr(134);                { Å - å }
  251.       128 : strName[n]:= chr(135);                { Ç - ç }
  252.       146 : strName[n]:= chr(145);                { Æ - æ }
  253.       153 : strName[n]:= chr(148);                { Oe - oe }
  254.       165 : strName[n]:= chr(164);                { Ñ - ñ }
  255.    65..90 : strName[n]:= chr(ord(strName[n])+32);
  256.     END;
  257.   LowerString:=StrName;
  258. END;
  259.  
  260. {----------------------------------------------------------------------------}
  261.  
  262. function RemoveLeft (remo,strName: String): String;
  263. { Original author: Orazio Czerwenka }
  264. var
  265.   b    : byte;
  266.   dummy: char;
  267.   remov: CharArray255;
  268.   function DummyInRemov: Boolean;
  269.   var
  270.     b    : byte;
  271.   begin
  272.     DummyInRemov:= true;
  273.     for b:= 1 to ord(remo[0]) do if dummy = remov[b] then exit;
  274.     DummyInRemov:= false;
  275.   end;
  276. begin
  277.   RemoveLeft:= strName;
  278.   if remo = '' then exit;
  279.   FillChar(remov,255,#0);
  280.   for b:= 1 to ord(remo[0]) do remov[b]:= remo[b];
  281.   Repeat
  282.     for b:= 1 to ord(remo[0]) do begin
  283.       dummy:= remo[b];
  284.       Repeat
  285.         if strName[1] = dummy then delete(strName,1,1);
  286.       Until (strName[1] <> dummy) or (strName = '');
  287.     end;
  288.     if strName <> ''
  289.       then dummy:= strName[1]
  290.       else dummy:= #0;
  291.     if not DummyInRemov then remov[1]:= #0;
  292.   Until (remov[1] = #0) or (strName = '');
  293.   RemoveLeft:= strName;
  294. end;
  295.  
  296. {----------------------------------------------------------------------------}
  297.  
  298. function RemoveRight (remo,strName: String): String;
  299. { Original author: Orazio Czerwenka }
  300. begin
  301.   RemoveRight:=
  302.     Mirrorstring(RemoveLeft(remo,MirrorString(strName)));
  303. end;
  304.  
  305. {----------------------------------------------------------------------------}
  306.  
  307. function RemoveLeftRight (remo,strName: String): String;
  308. { Original author: Orazio Czerwenka }
  309. var
  310.   dummy : string;
  311. begin
  312.   dummy:= RemoveLeft(remo,strName);
  313.   RemoveLeftRight:=
  314.     Mirrorstring(RemoveLeft(remo,MirrorString(dummy)));
  315. end;
  316.  
  317. {----------------------------------------------------------------------------}
  318.  
  319. function RemoveAll (remo,strName: String): String;
  320. { Original author: Orazio Czerwenka }
  321. var
  322.   i,
  323.   b: byte;
  324. begin
  325.   i:= 1;
  326.   Repeat
  327.     b:= 1;
  328.     Repeat
  329.       if strName[b] = remo[i] then delete(strName,b,1)
  330.       else inc(b);
  331.     Until b > ord(strName[0]);
  332.     inc(i);
  333.   Until i > ord(remo[0]);
  334.   RemoveAll:= strName;
  335. end;
  336.  
  337. {----------------------------------------------------------------------------}
  338.  
  339. function StripSpaceTAB (strName: String): String;
  340. { Original author: Peter Holschbach,
  341.   modifications Orazio Czerwenka }
  342. begin
  343.   StripSpaceTAB:= RemoveAll(' '+#9,strName);
  344. End;
  345.  
  346. {----------------------------------------------------------------------------}
  347.  
  348. function StripLeadingSpaceTAB (strName: String): String;
  349. { Original author: Peter Holschbach,
  350.   modifications Orazio Czerwenka }
  351. begin
  352.   StripLeadingSpaceTAB:= RemoveLeft(' '+#9,strName);
  353. end;
  354.  
  355. {----------------------------------------------------------------------------}
  356.  
  357. procedure PartString (PartBy: String; Var StringField : FieldOfStrings);
  358. { Original author: Peter Holschbach,
  359.   modifications Orazio Czerwenka
  360.   190994 modifications Peter Holschbach }
  361. Var
  362.   strName    : String;
  363.   Position : Word;
  364.   QuotationFound : Boolean;
  365. Begin
  366.   QuotationFound := False;
  367.   PartCount := 0;
  368.   strName := StringField [0];     (* the String to split *)
  369.   FillChar(StringField,SizeOf(StringField),0);  (* fill the whole Strings with '' *)
  370.   StringField[0]:= strName;
  371.   If StringField [0] = '' then Exit;
  372.   Repeat
  373.     Position := CharListNoPos(PartBy+'"',strName);
  374.     QuotationFound := (Position > 1) AND (strName [Position-1] = '"');
  375.     Delete (strName,1,Position-1);  (* delete all leading chars *)
  376.     If QuotationFound Then
  377.       Position := CharListPos('"',strName)
  378.     Else
  379.       Position := CharListPos(PartBy,strName);
  380.     If (Position = 0) then Begin
  381.       If strName <> '' then Begin
  382.         Inc (PartCount);
  383.         StringField [PartCount] := strName;
  384.         strName := '';
  385.       End
  386.     End
  387.     Else Begin
  388.       Inc (PartCount);
  389.       StringField [PartCount] := Copy (strName,1,Position - 1);
  390.       Delete (strName,1,Position);
  391.     End;
  392.   Until strName = '';
  393. End;
  394.  
  395. {----------------------------------------------------------------------------}
  396.  
  397. procedure PartStringBySpaceTAB (Var StringField : FieldOfStrings);
  398. { Original author: Peter Holschbach,
  399.   modifications Orazio Czerwenka }
  400. Begin
  401.   PartString (' '#9,StringField);
  402. End;
  403.  
  404. {----------------------------------------------------------------------------}
  405.  
  406. procedure PartStringByComma (Var StringField : FieldOfStrings);
  407. { Original author: Peter Holschbach,
  408.   modifications Orazio Czerwenka }
  409. Begin
  410.   PartString (',',StringField);
  411. End;
  412.  
  413. {----------------------------------------------------------------------------}
  414.  
  415.   { returns TRUE if the string in Source matches the string in Pattern
  416.     The pattern may contain any number of the wild characters '*' and '?'
  417.     '?' matches any single character
  418.     '*' matches any sequence of charcters (including a zero length sequence)
  419.     EG '*m?t*i*' will match 'Automatic' }
  420.  
  421. function WildMatch(Pattern,Source: String) : boolean;
  422. { Original author: Peter Schuette,
  423.   modifications Orazio Czerwenka }
  424.   function Rmatch(VAR s: String; i: Integer;
  425.                   VAR p: String; j: Integer) : boolean;
  426.   { s = to be tested ,    i = position in s }
  427.   { p = pattern to match ,j = position in p }
  428.   var
  429.     matched: Boolean;
  430.     k      : Integer;
  431.   BEGIN
  432.     IF p[0]=CHR(0) THEN Begin RMatch := True; Exit; End;
  433.     REPEAT
  434.       IF ((i > Length(s)) OR (s[i] = CHR(0))) AND
  435.          ((j > Length(p)) OR (p[j] = CHR(0))) THEN Begin
  436.         RMatch := True; Exit; End
  437.       ELSE IF ((j > Length(p)) OR (p[j] = CHR(0))) THEN Begin
  438.         RMatch := False; Exit; End
  439.       ELSE IF (p[j] = '*') THEN Begin
  440.         k :=i;
  441.         IF ((j = Length(p)) OR (p[j+1] = CHR(0))) THEN Begin
  442.           RMatch := True; Exit; End
  443.         ELSE Begin
  444.           REPEAT
  445.             matched := Rmatch(s,k,p,j+1);
  446.             INC(k);
  447.           UNTIL matched OR (k > Length(s)) OR (s[k] = CHR(0));
  448.           RMatch := matched; Exit;
  449.         END
  450.       End
  451.       ELSE IF (p[j] <> '?') AND (UpCase(p[j]) <> UpCase(s[i])) THEN Begin
  452.         RMatch := False; Exit; End
  453.       ELSE Begin
  454.         INC(i);
  455.         INC(j);
  456.       END;
  457.     Until 1=0;
  458.   END;
  459. BEGIN
  460.   WildMatch :=  Rmatch(Source,1,Pattern,1);
  461. END;
  462.  
  463. {----------------------------------------------------------------------------}
  464.  
  465.   { The resulting byte reports the degree the strings equal each other.
  466.     The higher the value, the more different the strings are. (0 reports
  467.     identical entries) }
  468.  
  469. function Resemble(a, b: String): Byte;
  470. { Original author: Peter Schuette,
  471.   modifications Orazio Czerwenka }
  472. Var i, sresult, sres1 : Byte;
  473.     xchnge, bcopy : String;
  474.     deleted : Boolean;
  475. Begin {Resemble}
  476.   sresult := 255;
  477.   If Length(a) < Length(b) Then Begin
  478.     xchnge := a;
  479.     a := b;
  480.     b := xchnge;
  481.   End;
  482.   If Length(a) < Length(b) Then
  483.     For i := 1 to Length(a) Do Begin
  484.       bcopy := b;
  485.       Insert(#0, bcopy, i);
  486.       sres1 := Resemble(a, bcopy);
  487.       If sres1 < sresult Then sresult := sres1;
  488.     End
  489.     Else Begin
  490.       sres1 := 0;
  491.        i := 1;
  492.        While i <= Length(a) Do
  493.          If a[i] = b[i] Then Begin
  494.            Delete(a, i, 1);
  495.            Delete(b, i, 1);
  496.          End
  497.          Else inc(i);
  498.        i := 2;
  499.        deleted := False;
  500.        While i <= Length(a) Do
  501.          If a[i] = b[i-1] Then Begin
  502.            Delete(a, i, 1);
  503.            Delete(b, i-1, 1);
  504.            deleted := True;
  505.          End
  506.          Else inc(i);
  507.        If deleted Then inc(sres1);
  508.        i := 2;
  509.        deleted := False;
  510.        While i <= Length(b) Do
  511.          If a[i-1] = b[i] Then Begin
  512.            Delete(a, i-1, 1);
  513.            Delete(b, i, 1);
  514.            deleted := True;
  515.          End
  516.          Else inc(i);
  517.        If deleted Then inc(sres1);
  518.        sres1 := sres1 + Length(a);
  519.        if sres1 < sresult then sresult := sres1
  520.     End;
  521.     resemble := sresult;
  522. End; {Resemble}
  523.  
  524. {----------------------------------------------------------------------------}
  525.  
  526. function EnsureBackslash (strName:String) : String;
  527. { Original author: Peter Holschbach,
  528.   modifications Orazio Czerwenka }
  529. begin
  530.   if strName[ord(strName[0])] <> '\' then EnsureBackslash:= strName + '\'
  531.   else EnsureBackslash:= strName;
  532. end;
  533.  
  534. {----------------------------------------------------------------------------}
  535.  
  536. function EnsureNoBackslash (strName:String) : String;
  537. { Original author: Orazio Czerwenka }
  538. begin
  539.   EnsureNoBackslash:= RemoveRight(' \',strName);
  540. end;
  541.  
  542. {----------------------------------------------------------------------------}
  543.  
  544. Function  EscToString (strName:String) : String;
  545. { Original author: Peter Holschbach }
  546.  
  547. Var s : String;
  548.     L : Byte;
  549.  
  550. Begin
  551.   s := '';
  552.   for L := 1 to Length (StrName) do Begin
  553.     If StrName [L] = '^' then Begin
  554.       s := s + '^^';
  555.     End
  556.     Else If Ord (strName [L]) < 64 then Begin
  557.       s := s + '^' + Chr (Ord (strName [L]) + 64);
  558.     End
  559.     Else Begin
  560.       s := s + strName [L]
  561.     End;
  562.   End;
  563.   EscToString := s;
  564. End;
  565.  
  566. {----------------------------------------------------------------------------}
  567.  
  568. Function  StringToEsc (strName:String) : String;
  569. { Original author: Peter Holschbach }
  570.  
  571. Var s : String;
  572.     L : Byte;
  573.  
  574. Begin
  575.   L := 1;
  576.   s := '';
  577.   While L < Length (strName) do Begin
  578.     If StrName [L] = '^' Then Begin
  579.       If (StrName [L+1] <> '^') AND (ORD (StrName [L+1]) >= 64) Then Begin
  580.         S := s + Chr (ORD (StrName [L+1]) - 64);
  581.         INC (L,2);
  582.       End
  583.       Else Begin
  584.         S:= S + StrName [L] + StrName [L+1];
  585.         Inc (L,2);
  586.       End;
  587.     End
  588.     Else Begin
  589.       s := s + StrName [L];
  590.       Inc (L);
  591.     End;
  592.   End;
  593.   StringToEsc := S;
  594. End;
  595.  
  596. {----------------------------------------------------------------------------}
  597.  
  598. END.
  599.  
  600.